home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / derived / ast-builders.scm next >
Encoding:
Text File  |  1994-09-27  |  6.3 KB  |  163 lines  |  [TEXT/CCL2]
  1. (**true) (**con/def (core-symbol "True")))
  2.  
  3. (define (**false) (**con/def (core-symbol "False")))
  4.  
  5. ;; Tuples
  6.  
  7. (define (**tuple2 x y)
  8.   (**app (**con/def (tuple-constructor 2)) x y))
  9.  
  10. (define (**tupleN exps)
  11.   (**app/l (**con/def (tuple-constructor (length exps))) exps))
  12.  
  13. ;; Arithmetic
  14.  
  15. (define (**+ x y)
  16.   (**app (**var/def (core-symbol "+")) x y))
  17.  
  18. (define (**+/Int x y)
  19.   (**app (**var/def (core-symbol "primPlusInt")) x y))
  20.  
  21. (define (**- x y)
  22.   (**app (**var/def (core-symbol "-")) x y))
  23.  
  24. (define (**1+ x)
  25.   (**+ x (**int 1)))
  26.  
  27. (define (**list/pattern pats)
  28.   (if (null? pats)
  29.       (**pcon/def (core-symbol "Nil") '())
  30.       (**pcon/def (core-symbol ":")
  31.           (list (car pats) (**list/pattern (cdr pats))))))
  32.  
  33. (define (**append . lists)
  34.   (**append/l lists))
  35.  
  36. (define (**append/l lists)
  37.   (if (null? (cdr lists))
  38.       (car lists)
  39.       (**app (**var/def (core-symbol "++"))
  40.          (car lists)
  41.          (**append/l (cdr lists)))))
  42.  
  43. (define (**take n l)
  44.   (**app (**var/def (core-symbol "take")) n l))
  45.  
  46. (define (**drop n l)
  47.   (**app (**var/def (core-symbol "drop")) n l))
  48.  
  49. ;; Functionals
  50.  
  51. (define (**dot fn . args)
  52.   (**dot/l fn args))
  53.  
  54. (define (**dot/l fn args)
  55.  (if (null? args)
  56.      fn
  57.      (**app (**var/def (core-symbol ".")) fn (**dot/l (car args) (cdr args)))))
  58.  
  59. ;; Printing
  60.  
  61. (define (**showChar x)
  62.   (**app (**var/def (core-symbol "showChar")) x))
  63.  
  64. (define (**space)
  65.   (**showChar (**char #\ )))
  66.  
  67. (define (**comma)
  68.   (**showChar (**char #\,)))
  69.  
  70. (define (**showsPrec x y)
  71.   (**app (**var/def (core-symbol "showsPrec")) x y))
  72.  
  73. (define (**shows x)
  74.   (**app (**var/def (core-symbol "shows")) x))
  75.  
  76. (define (**showString x)
  77.   (**app (**var/def (core-symbol "showString")) x))
  78.  
  79. (define (**showParen x y)
  80.   (**app (**var/def (core-symbol "showParen")) x y))
  81.  
  82. ;; Reading
  83.  
  84. (define (**readsPrec x y)
  85.   (**app (**var/def (core-symbol "readsPrec")) x y))
  86.  
  87. (define (**lex x)
  88.   (**app (**var/def (core-symbol "lex")) x))
  89.  
  90. (define (**readParen bool fn r)
  91.   (**app (**var/def (core-symbol "readParen")) bool fn r))
  92.  
  93. (define (**reads s)
  94.   (**app (**var/def (core-symbol "reads")) s))
  95.  
  96. ;;; Binary
  97.  
  98. (define (**showBinInt i b)
  99.   (**app (**var/def (core-symbol "primShowBinInt")) i b))
  100.  
  101. (define (**readBinSmallInt max b)
  102.   (**app (**var/def (core-symbol "primReadBinSmallInt")) max b))
  103.  
  104. (define (**showBin x b)
  105.   (**app (**var/def (core-symbol "showBin")) x b))
  106.  
  107. (define (**readBin b)
  108.   (**app (**var/def (core-symbol "readBin")) b))
  109.  
  110. ;;; Some higher level code generators
  111.  
  112. ;;; foldr  (expanded inline)
  113.  
  114. (define (**foldr build-fn terms init)
  115.   (if (null? terms)
  116.       init
  117.       (funcall build-fn (car terms) (**foldr build-fn (cdr terms) init))))
  118.  
  119. ;;; Unlike foldr, this uses two sets of args to avoid tupling
  120.  
  121. (define (**foldr2 build-fn terms1 terms2 init-fn)
  122.   (if (null? (cdr terms1))
  123.       (funcall init-fn (car terms1) (car terms2))
  124.       (funcall build-fn (car terms1) (car terms2)
  125.           (**foldr2 build-fn (cdr terms1) (cdr terms2) init-fn))))
  126.  
  127. ;;; Enum
  128.  
  129. (define (**enumFrom x)
  130.   (**app (**var/def (core-symbol "enumFrom")) x))
  131.  
  132. (define (**enumFromThen from then)
  133.   (**app (**var/def (core-symbol "enumFromThen")) from then))
  134.  
  135. (define (**enumFromTo from to)
  136.   (**app (**var/def (core-symbol "enumFromTo")) from to))
  137.  
  138. (define (**enumFromThenTo from then to)
  139.   (**app (**var/def (core-symbol "enumFromThenTo")) from then to))
  140.  
  141. ;;; Case.  This also generates the alts.  All variants of case generate
  142. ;;; an arm for each constructor in a datatype.  This arm can be selected
  143. ;;; by pattern matching a value of the type, with all fields bound to vars,
  144. ;;; or with numbered or named selections.
  145.  
  146. ;;; The fn always generates the arms given the constructor.  In the /con case,
  147. ;;; the fn also gets the variable list of values bound in the fields.
  148.  
  149. (define (**case/con alg exp fn)
  150.   (**case exp
  151.       (map (lambda (con)
  152.          (let* ((arity (con-arity con))
  153.             (vars (temp-vars "x" arity)))
  154.            (**alt/simple (**pat (cons con vars))
  155.                  (funcall fn con vars))))
  156.            (algdata-constrs alg))))
  157.  
  158. ;;; Selectors are integers (used for Bin)
  159.  
  160. (define (**case/int alg exp fn)
  161.   (**case exp
  162.     (map (lambda (con)
  163.        (**alt